home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-delete.el.z / vm-delete.el
Encoding:
Text File  |  1998-05-21  |  11.2 KB  |  308 lines
  1. ;;; Delete and expunge commands for VM.
  2. ;;; Copyright (C) 1989-1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-delete)
  19.  
  20. (defun vm-delete-message (count)
  21.   "Add the `deleted' attribute to the current message.
  22.  
  23. The message will be physically deleted from the current folder the next
  24. time the current folder is expunged.
  25.  
  26. With a prefix argument COUNT, the current message and the next
  27. COUNT - 1 messages are deleted.  A negative argument means
  28. the current message and the previous |COUNT| - 1 messages are
  29. deleted.
  30.  
  31. When invoked on marked messages (via vm-next-command-uses-marks),
  32. only marked messages are deleted, other messages are ignored."
  33.   (interactive "p")
  34.   (if (interactive-p)
  35.       (vm-follow-summary-cursor))
  36.   (vm-select-folder-buffer)
  37.   (vm-check-for-killed-summary)
  38.   (vm-error-if-folder-read-only)
  39.   (vm-error-if-folder-empty)
  40.   (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
  41.     (mlist (vm-select-marked-or-prefixed-messages count))
  42.     (del-count 0))
  43.     (while mlist
  44.       (if (not (vm-deleted-flag (car mlist)))
  45.       (progn
  46.         (vm-set-deleted-flag (car mlist) t)
  47.         (vm-increment del-count)))
  48.       (setq mlist (cdr mlist)))
  49.     (vm-display nil nil '(vm-delete-message vm-delete-message-backward)
  50.         (list this-command))
  51.     (if (and used-marks (interactive-p))
  52.     (if (zerop del-count)
  53.         (message "No messages deleted")
  54.       (message "%d message%s deleted"
  55.            del-count
  56.            (if (= 1 del-count) "" "s"))))
  57.     (vm-update-summary-and-mode-line)
  58.     (if (and vm-move-after-deleting (not used-marks))
  59.     (let ((vm-circular-folders (and vm-circular-folders
  60.                     (eq vm-move-after-deleting t))))
  61.       (vm-next-message count t executing-kbd-macro)))))
  62.  
  63. (defun vm-delete-message-backward (count)
  64.   "Like vm-delete-message, except the deletion direction is reversed."
  65.   (interactive "p")
  66.   (if (interactive-p)
  67.       (vm-follow-summary-cursor))
  68.   (vm-delete-message (- count)))
  69.  
  70. (defun vm-undelete-message (count)
  71.   "Remove the `deleted' attribute from the current message.
  72.  
  73. With a prefix argument COUNT, the current message and the next
  74. COUNT - 1 messages are undeleted.  A negative argument means
  75. the current message and the previous |COUNT| - 1 messages are
  76. deleted.
  77.  
  78. When invoked on marked messages (via vm-next-command-uses-marks),
  79. only marked messages are undeleted, other messages are ignored."
  80.   (interactive "p")
  81.   (if (interactive-p)
  82.       (vm-follow-summary-cursor))
  83.   (vm-select-folder-buffer)
  84.   (vm-check-for-killed-summary)
  85.   (vm-error-if-folder-read-only)
  86.   (vm-error-if-folder-empty)
  87.   (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
  88.     (mlist (vm-select-marked-or-prefixed-messages count))
  89.     (undel-count 0))
  90.     (while mlist
  91.       (if (vm-deleted-flag (car mlist))
  92.       (progn
  93.         (vm-set-deleted-flag (car mlist) nil)
  94.         (vm-increment undel-count)))
  95.       (setq mlist (cdr mlist)))
  96.     (if (and used-marks (interactive-p))
  97.     (if (zerop undel-count)
  98.         (message "No messages undeleted")
  99.       (message "%d message%s undeleted"
  100.            undel-count
  101.            (if (= 1 undel-count)
  102.                "" "s"))))
  103.     (vm-display nil nil '(vm-undelete-message) '(vm-undelete-message))
  104.     (vm-update-summary-and-mode-line)
  105.     (if (and vm-move-after-undeleting (not used-marks))
  106.     (let ((vm-circular-folders (and vm-circular-folders
  107.                     (eq vm-move-after-undeleting t))))
  108.       (vm-next-message count t executing-kbd-macro)))))
  109.  
  110. (defun vm-kill-subject (&optional arg)
  111.   "Delete all messages with the same subject as the current message.
  112. Message subjects are compared after ignoring parts matched by
  113. the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix.
  114.  
  115. The optional prefix argument ARG specifies the direction to move
  116. if vm-move-after-killing is non-nil.  The default direction is
  117. forward.  A positive prefix argument means move forward, a
  118. negative arugment means move backward, a zero argument means
  119. don't move at all."
  120.   (interactive "p")
  121.   (vm-follow-summary-cursor)
  122.   (vm-select-folder-buffer)
  123.   (vm-check-for-killed-summary)
  124.   (vm-error-if-folder-read-only)
  125.   (vm-error-if-folder-empty)
  126.   (let ((subject (vm-so-sortable-subject (car vm-message-pointer)))
  127.     (mp vm-message-list)
  128.     (n 0)
  129.     (case-fold-search t))
  130.     (while mp
  131.       (if (and (not (vm-deleted-flag (car mp)))
  132.            (string-equal subject (vm-so-sortable-subject (car mp))))
  133.       (progn
  134.         (vm-set-deleted-flag (car mp) t)
  135.         (vm-increment n)))
  136.       (setq mp (cdr mp)))
  137.     (and (interactive-p)
  138.      (if (zerop n)
  139.          (message "No messages deleted.")
  140.        (message "%d message%s deleted" n (if (= n 1) "" "s")))))
  141.   (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject))
  142.   (vm-update-summary-and-mode-line)
  143.   (cond ((or (not (numberp arg)) (> arg 0))
  144.      (setq arg 1))
  145.     ((< arg 0)
  146.      (setq arg -1))
  147.     (t (setq arg 0)))
  148.   (if vm-move-after-killing
  149.       (let ((vm-circular-folders (and vm-circular-folders
  150.                       (eq vm-move-after-killing t))))
  151.     (vm-next-message arg t executing-kbd-macro))))
  152.  
  153. (defun vm-expunge-folder (&optional shaddap)
  154.   "Expunge messages with the `deleted' attribute.
  155. For normal folders this means that the deleted messages are
  156. removed from the message list and the message contents are
  157. removed from the folder buffer.
  158.  
  159. For virtual folders, messages are removed from the virtual
  160. message list.  If virtual mirroring is in effect for the virtual
  161. folder, the corresponding real messages are also removed from real
  162. message lists and the message contents are removed from real folders.
  163.  
  164. When invoked on marked messages (via vm-next-command-uses-marks),
  165. only messages both marked and deleted are expunged, other messages are
  166. ignored."
  167.   (interactive)
  168.   (vm-select-folder-buffer)
  169.   (vm-check-for-killed-summary)
  170.   (vm-error-if-folder-read-only)
  171.   ;; do this so we have a clean slate.  code below depends on the
  172.   ;; fact that the numbering redo start point begins as nil in
  173.   ;; all folder buffers.
  174.   (vm-update-summary-and-mode-line)
  175.   (if (not shaddap)
  176.       (message "Expunging..."))
  177.   (let ((use-marks (eq last-command 'vm-next-command-uses-marks))
  178.     (mp vm-message-list)
  179.     (virtual (eq major-mode 'vm-virtual-mode))
  180.     (buffers-altered (make-vector 29 0))
  181.     prev virtual-messages)
  182.     (while mp
  183.       (cond
  184.        ((and (vm-deleted-flag (car mp))
  185.          (or (not use-marks)
  186.          (vm-mark-of (car mp))))
  187.     ;; remove the message from the thread tree.
  188.     (if vm-thread-obarray
  189.         (vm-unthread-message (vm-real-message-of (car mp))))
  190.     ;; expunge from the virtual side first, removing all
  191.     ;; references to this message before actually removing
  192.     ;; the message itself.
  193.     (cond
  194.      ((setq virtual-messages (vm-virtual-messages-of (car mp)))
  195.       (let (vms prev curr)
  196.         (if virtual
  197.         (setq vms (cons (vm-real-message-of (car mp))
  198.                 (vm-virtual-messages-of (car mp))))
  199.           (setq vms (vm-virtual-messages-of (car mp))))
  200.         (while vms
  201.           (save-excursion
  202.         (set-buffer (vm-buffer-of (car vms)))
  203.         (setq prev (vm-reverse-link-of (car vms))
  204.               curr (or (cdr prev) vm-message-list))
  205.         (intern (buffer-name) buffers-altered)
  206.         (vm-set-numbering-redo-start-point (or prev t))
  207.         (vm-set-summary-redo-start-point (or prev t))
  208.         (if (eq vm-message-pointer curr)
  209.             (setq vm-system-state nil
  210.               vm-message-pointer (or prev (cdr curr))))
  211.         (if (eq vm-last-message-pointer curr)
  212.             (setq vm-last-message-pointer nil))
  213.         ;; lock out interrupts to preserve message-list integrity
  214.         (let ((inhibit-quit t))
  215.           ;; vm-clear-expunge-invalidated-undos uses
  216.           ;; this to recognize expunged messages.
  217.           ;; If this stuff is mirrored we'll be
  218.           ;; setting this value multiple times if there
  219.           ;; are multiple virtual messages referencing
  220.           ;; the underlying real message.  Harmless.
  221.           (vm-set-deleted-flag-of (car curr) 'expunged)
  222.           ;; disable summary any summary update that may have
  223.           ;; already been scheduled.
  224.           (vm-set-su-start-of (car curr) nil)
  225.           (vm-increment vm-modification-counter)
  226.           (if (null prev)
  227.               (progn
  228.             (setq vm-message-list (cdr vm-message-list))
  229.             (and (cdr curr)
  230.                  (vm-set-reverse-link-of (car (cdr curr)) nil)))
  231.             (setcdr prev (cdr curr))
  232.             (and (cdr curr)
  233.              (vm-set-reverse-link-of (car (cdr curr)) prev)))
  234.           (vm-set-virtual-messages-of (car mp) (cdr vms))
  235.           (vm-set-buffer-modified-p t)))
  236.           (setq vms (cdr vms))))))
  237.     (cond
  238.      ((or (not virtual-messages)
  239.           (not virtual))
  240.       (and (not virtual-messages) virtual
  241.            (vm-set-virtual-messages-of
  242.         (vm-real-message-of (car mp))
  243.         (delq (car mp) (vm-virtual-messages-of
  244.                 (vm-real-message-of (car mp))))))
  245.       (if (eq vm-message-pointer mp)
  246.           (setq vm-system-state nil
  247.             vm-message-pointer (or prev (cdr mp))))
  248.       (if (eq vm-last-message-pointer mp)
  249.           (setq vm-last-message-pointer nil))
  250.       (intern (buffer-name) buffers-altered)
  251.       (if (null vm-numbering-redo-start-point)
  252.           (progn 
  253.         (vm-set-numbering-redo-start-point (or prev t))
  254.         (vm-set-summary-redo-start-point (or prev t))))
  255.       ;; lock out interrupt to preserve message list integrity
  256.       (let ((inhibit-quit t))
  257.         (if (null prev)
  258.         (progn (setq vm-message-list (cdr vm-message-list))
  259.                (and (cdr mp)
  260.                 (vm-set-reverse-link-of (car (cdr mp)) nil)))
  261.           (setcdr prev (cdr mp))
  262.           (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev)))
  263.         ;; vm-clear-expunge-invalidated-undos uses this to recognize
  264.         ;; expunged messages.
  265.         (vm-set-deleted-flag-of (car mp) 'expunged)
  266.         ;; disable summary any summary update that may have
  267.         ;; already been scheduled.
  268.         (vm-set-su-start-of (car mp) nil)
  269.         (vm-set-buffer-modified-p t)
  270.         (vm-increment vm-modification-counter))))
  271.     (if (eq (vm-attributes-of (car mp))
  272.         (vm-attributes-of (vm-real-message-of (car mp))))
  273.         (save-excursion
  274.           (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
  275.           (vm-save-restriction
  276.            (widen)
  277.            (let ((buffer-read-only nil))
  278.          (delete-region (vm-start-of (vm-real-message-of (car mp)))
  279.                 (vm-end-of (vm-real-message-of (car mp)))))))))
  280.        (t (setq prev mp)))
  281.       (setq mp (cdr mp)))
  282.     (vm-display nil nil '(vm-expunge-folder) '(vm-expunge-folder))
  283.     (cond
  284.      (buffers-altered
  285.       (save-excursion
  286.     (mapatoms
  287.      (function
  288.       (lambda (buffer)
  289.         (set-buffer (symbol-name buffer))
  290.         (if (null vm-system-state)
  291.         (progn
  292.           (vm-garbage-collect-message)
  293.           (if (null vm-message-pointer)
  294.               ;; folder is now empty
  295.               (progn (setq vm-folder-type nil)
  296.                  (vm-update-summary-and-mode-line))
  297.             (vm-preview-current-message)))
  298.           (vm-update-summary-and-mode-line))
  299.         (if (not (eq major-mode 'vm-virtual-mode))
  300.         (setq vm-message-order-changed
  301.               (or vm-message-order-changed
  302.               vm-message-order-header-present)))
  303.         (vm-clear-expunge-invalidated-undos)))
  304.      buffers-altered))
  305.       (if (not shaddap)
  306.       (message "Deleted messages expunged.")))
  307.      (t (message "No messages are flagged for deletion.")))))
  308.